Visual Basic Toolbox

home *** CD-ROM | disk | FTP | other *** search

/ Visual Basic Toolbox / Visual Basic Toolbox (P.I.E.)(1996).ISO / toolkit / riruf1 / empform.frm (.txt) < prev next >

Wrap

Visual Basic Form | 1995-05-19 | 15.1 KB | 567 lines

VERSION 2.00 Begin Form EmpForm BackColor = &H00C0C0C0& BorderStyle = 1 'Fixed Single Caption = "Employee Data" ClientHeight = 4800 ClientLeft = 1860 ClientTop = 1515 ClientWidth = 5445 Height = 5205 KeyPreview = -1 'True Left = 1800 LinkTopic = "Form2" MaxButton = 0 'False MinButton = 0 'False ScaleHeight = 4800 ScaleWidth = 5445 Top = 1170 Width = 5565 Begin SSFrame Frame3D1 Font3D = 0 'None Height = 2175 Left = 120 TabIndex = 13 Top = 2520 Width = 5175 Begin ComboBox cboState Height = 300 Left = 3000 Style = 2 'Dropdown List TabIndex = 11 Top = 1680 Width = 855 End Begin SSCheck chkActive Caption = "&Active" Font3D = 0 'None Height = 255 Left = 4080 TabIndex = 12 Top = 1680 Width = 855 End Begin ComboBox cboWage Height = 300 Left = 1800 Sorted = -1 'True TabIndex = 10 Top = 1680 Width = 1095 End Begin ComboBox cboStatus Height = 300 Left = 120 Style = 2 'Dropdown List TabIndex = 8 Top = 960 Width = 1815 End Begin MaskEdBox txtHireDate Height = 285 Left = 120 Mask = "##/##/####" MaxLength = 10 PromptChar = "_" TabIndex = 9 Top = 1680 Width = 1335 End Begin TextBox txtFirstName Height = 285 Left = 120 MaxLength = 20 TabIndex = 6 Top = 360 Width = 2295 End Begin TextBox txtLastName Height = 285 Left = 2640 MaxLength = 20 TabIndex = 7 Top = 360 Width = 2295 End Begin Label Label7 BackColor = &H00C0C0C0& Caption = "State:" Height = 255 Left = 3000 TabIndex = 21 Top = 1440 Width = 615 End Begin Label Label6 BackColor = &H00C0C0C0& Caption = "Wage:" Height = 255 Left = 1800 TabIndex = 20 Top = 1440 Width = 615 End Begin Label lblEmpNo BackColor = &H00C0C0C0& Height = 255 Left = 2640 TabIndex = 19 Top = 960 Width = 735 End Begin Label Label5 BackColor = &H00C0C0C0& Caption = "Status:" Height = 255 Left = 120 TabIndex = 18 Top = 720 Width = 615 End Begin Label Label4 BackColor = &H00C0C0C0& Caption = "Hire Date:" Height = 255 Left = 120 TabIndex = 17 Top = 1440 Width = 975 End Begin Label Label3 BackColor = &H00C0C0C0& Caption = "First Name:" Height = 255 Left = 120 TabIndex = 16 Top = 120 Width = 1095 End Begin Label Label2 BackColor = &H00C0C0C0& Caption = "Last Name:" Height = 255 Left = 2640 TabIndex = 15 Top = 120 Width = 1095 End Begin Label Label1 BackColor = &H00C0C0C0& Caption = "Employee Number:" Height = 255 Left = 2640 TabIndex = 14 Top = 720 Width = 1695 End End Begin CommandButton cmdDelete Caption = "&Delete" Height = 375 Left = 3840 TabIndex = 4 Top = 1560 Width = 1215 End Begin CommandButton cmdUpdate Caption = "&Update" Enabled = 0 'False Height = 375 Left = 3840 TabIndex = 3 Top = 1080 Width = 1215 End Begin CommandButton cmdNew Caption = "&New" Height = 375 Left = 3840 TabIndex = 2 Top = 600 Width = 1215 End Begin CommandButton cmdEdit Caption = "&Edit" Default = -1 'True Height = 375 Left = 3840 TabIndex = 1 Top = 120 Width = 1215 End Begin ListBox lstEmps Height = 2370 Left = 120 TabIndex = 0 Top = 120 Width = 3255 End Begin CommandButton cmdClose Cancel = -1 'True Caption = "&Close" Height = 375 Left = 3840 TabIndex = 5 Top = 2040 Width = 1215 End Option Explicit Dim dsData As dynaset Dim bNew%, bChange%, bLocked% Dim lEmpNo& Dim bOpen% Sub cboState_Change () bChange = True End Sub Sub cboStatus_Change () bChange = True End Sub Sub cboWage_Change () bChange = True End Sub Sub cboWage_LostFocus () CheckAndSaveCbo cboWage, "Wages", "Wage", True End Sub Function CheckChange () As Integer Dim nResponse% If bChange = True Then Beep nResponse = MsgBox("Discard current changes ?", MB_YESNO + MB_ICONQUESTION, TheAppTitle) If nResponse = IDYES Then CheckChange = True Else CheckChange = False End If Else CheckChange = True End If End Function Sub chkActive_Click (Value As Integer) bChange = True End Sub Sub cmdClose_Click () If CheckChange() Then Unload EmpForm End If End Sub Sub cmdDelete_Click () On Error GoTo delErr Dim ssData As snapshot Dim qd As querydef lEmpNo = GetLBID(lstEmps, "Employee") If lEmpNo = -1 Then Exit Sub End If If Not AskUser("Are you sure you want to delete the selected record?") Then ArrowCursor Exit Sub End If If bLocked Then dsData.Update bLocked = False End If Set qd = TheDatabase.OpenQueryDef("DeleteEmployee") qd!id = lEmpNo ' Set parameter. qd.Execute txtLastName.Text = "" txtFirstName.Text = "" SelectText txtHireDate txtHireDate.SelText = "" chkActive.Value = False 'reset combos cboStatus.ListIndex = -1 cboWage.ListIndex = -1 cboWage.Text = "" cboState.ListIndex = -1 LoadListBox "GetAllEmps", -1, lstEmps, False, "," bNew = False cmdNew.Caption = "&New" cmdUpdate.Caption = "&Update" cmdUpdate.Enabled = False DoEvents bChange = False ArrowCursor Exit Sub delErr: ArrowCursor GetErrorMsg Err Exit Sub End Sub Sub cmdEdit_Click () On Error GoTo editErr Dim qd As querydef Dim sBuff$, sTmp$, sLine$, sKey$, stat$, lTmp& 'check for list box selection lEmpNo = GetLBID(lstEmps, "Employee") If lEmpNo = -1 Then Exit Sub End If HourglassCursor bNew = False 'check for currently loaded record If CheckChange() Then Enable True Set qd = TheDatabase.OpenQueryDef("GetAllEmpData") Set dsData = qd.CreateDynaset() bOpen = True qd.Close sBuff = "EmpNo = " & Str$(lEmpNo) dsData.FindFirst sBuff If dsData.NoMatch Then InformUser "ID no longer available: " Else dsData.Edit bLocked = True lblEmpNo.Caption = lEmpNo txtLastName.Text = ReturnString("LastName") txtFirstName.Text = ReturnString("FirstName") SelectText txtHireDate txtHireDate.SelText = Format$(ReturnString("HireDate"), "mm/dd/yyyy") If Not IsNull(dsData("Status")) Then ScanCombo dsData("Status"), cboStatus Else cboStatus.ListIndex = -1 End If cboWage.Text = Format$(ReturnString("Wage"), "##.00") FindState ReturnString("State"), cboState If Not IsNull(dsData("Active")) Then chkActive.Value = Val(dsData("Active")) Else chkActive.Value = False End If SelectText txtLastName SelectText txtFirstName SelectText txtHireDate cmdUpdate.Caption = "&Update" cmdUpdate.Enabled = True DoEvents bChange = False bNew = False txtFirstName.SetFocus End If End If ArrowCursor Exit Sub editErr: ArrowCursor GetErrorMsg Err Exit Sub End Sub Sub cmdNew_Click () 'blank fields txtLastName.Text = "" txtFirstName.Text = "" lblEmpNo.Caption = "" 'reset combos cboStatus.ListIndex = -1 cboWage.ListIndex = -1 cboWage.Text = "" cboState.ListIndex = -1 If Not bNew Then lEmpNo = GetID("Employee") lblEmpNo.Caption = Str$(lEmpNo) SelectText txtHireDate txtHireDate.SelText = Format$(Now, "mm/dd/yyyy") chkActive.Value = True Enable True bNew = True cmdNew.Caption = "&Cancel" cmdUpdate.Caption = "&Save" cmdUpdate.Enabled = True txtFirstName.SetFocus Else Enable False bNew = False SelectText txtHireDate txtHireDate.SelText = "" chkActive.Value = False cmdNew.Caption = "&New" cmdUpdate.Caption = "&Update" cmdUpdate.Enabled = False End If DoEvents bChange = False End Sub Sub cmdUpdate_Click () On Error GoTo UpdateErr Dim qd As querydef Dim sTmp$ If Len(LTrim$(txtLastName.Text)) < 1 Then StopUser "Last name cannot be blank!" Exit Sub End If If Len(LTrim$(txtFirstName.Text)) < 1 Then StopUser "First name cannot be blank!" Exit Sub End If HourglassCursor If bNew Then Set qd = TheDatabase.OpenQueryDef("GetAllEmpData") Set dsData = qd.CreateDynaset() bOpen = True qd.Close If dsData.EOF And dsData.BOF Then dsData.AddNew dsData("EmpNo") = lEmpNo dsData.Update dsData.MoveFirst Else dsData.AddNew dsData("EmpNo") = lEmpNo dsData.Update dsData.MoveLast End If dsData.Edit End If dsData("LastName") = txtLastName.Text dsData("FirstName") = txtFirstName.Text dsData("HireDate") = txtHireDate.Text If cboStatus.ListIndex = -1 Then dsData("Status") = -1 Else dsData("Status") = cboStatus.ItemData(cboStatus.ListIndex) End If dsData("Active") = LTrim$(Str$(Abs(chkActive.Value))) dsData("Wage") = Val(cboWage.Text) dsData("State") = LTrim$(cboState.Text) dsData.Update bNew = False cmdNew.Caption = "&New" bLocked = False Enable False cmdUpdate.Enabled = False cmdUpdate.Caption = "&Update" DoEvents bChange = False LoadListBox "GetAllEmps", lEmpNo, lstEmps, False, "," ArrowCursor Exit Sub UpdateErr: ArrowCursor GetErrorMsg Err Exit Sub End Sub Sub Enable (bVal%) cboStatus.Enabled = bVal cboWage.Enabled = bVal cboState.Enabled = bVal txtLastName.Enabled = bVal txtFirstName.Enabled = bVal txtHireDate.Enabled = bVal chkActive.Enabled = bVal End Sub Sub Form_KeyDown (KeyCode As Integer, Shift As Integer) If KeyCode = KEY_F1 Then CallHelp Employee_Data_Form End If End Sub Sub Form_Load () Enable False bNew = False bOpen = False bChange = False bLocked = False LoadListBox "GetAllEmps", -1, lstEmps, False, "," LoadCombo "GetActiveStatuses", -1, cboStatus, False, "", True LoadCombo2 "GetWages", -1, cboWage, False, "", True, True FillStates cboState End Sub Sub Form_Unload (Cancel As Integer) If bOpen Then dsData.Close End If End Sub Sub LoadCombo2 (sQDef As String, lDefault As Long, cboCtrl As ComboBox, bParam As Integer, sSeparator As String, bClear As Integer, bPad%) On Error GoTo lc2Err Dim ssData As snapshot Dim qDef As querydef Dim sLine$, i%, nIndex%, sSep$, sTmp$ HourglassCursor nIndex = -1 Set qDef = TheDatabase.OpenQueryDef(sQDef) If bParam Then qDef!Param = lDefault End If Set ssData = qDef.CreateSnapshot() qDef.Close If Len(sSeparator) = 0 Then sSep = " " Else sSep = sSeparator & " " End If If bClear Then cboCtrl.Clear End If While Not ssData.EOF If Not IsNull(ssData(0)) Then sLine = "" For i = 0 To ssData.Fields.Count - 1 If Not IsNull(ssData(i)) Then If bPad Then sLine = sLine & Format$(AddQuoteV(ssData(i)), "##.00") Else sLine = sLine & AddQuoteV(ssData(i)) End If If i < ssData.Fields.Count - 1 Then sLine = sLine & sSep End If End If Next cboCtrl.AddItem sLine If lDefault <> -1 Then If lDefault = ssData(0) Then nIndex = cboCtrl.NewIndex End If End If End If ssData.MoveNext Wend ssData.Close If nIndex <> -1 Then cboCtrl.ListIndex = nIndex End If ArrowCursor Exit Sub lc2Err: ArrowCursor GetErrorMsg Err Exit Sub End Sub Sub lstEmps_DblClick () cmdEdit = True End Sub Function ReturnString$ (sField$) If Not IsNull(dsData(sField)) Then ReturnString = dsData(sField) Else ReturnString = "" End If End Function Sub txtFirstName_Change () bChange = True End Sub Sub txtFirstName_LostFocus () SelectText txtFirstName End Sub Sub txtHireDate_Change () bChange = True If InStr(txtHireDate.Text, "_") = 0 Then If ValidateDate(txtHireDate) Then cmdUpdate.Enabled = True Else cmdUpdate.Enabled = False End If Else cmdUpdate.Enabled = False End If End Sub Sub txtHireDate_LostFocus () SelectText txtHireDate End Sub Sub txtLastName_Change () bChange = True End Sub Sub txtLastName_LostFocus () SelectText txtLastName End Sub